
type t =
    Class of string
  | Method of t list * t

let string_of_type =
  function
      Class cls -> cls
    | Method _ -> assert false

let get_class st cls =
  try
    List.assoc cls st
  with
      Not_found ->
	prerr_endline (Printf.sprintf "INTERNAL ERROR: %s not found" (string_of_type cls));
	raise Not_found

let rec get_fields st =
  function
      Class "Object" -> []
    | cls ->
	match get_class st cls with
	    AstO.Class (_, base_cls, fields, _) ->
	      List.map (fun (typ, x) -> (x, Class typ)) fields @ get_fields st (Class base_cls)

let type_of_field st cls field_name = List.assoc field_name (get_fields st cls)

let rec type_of_method st cls method_name =
  let is_method (AstO.Method (_, _, name, _, _)) = method_name = name in
    match get_class st cls with
	AstO.Class ("Object", _, _, _) ->
	  prerr_endline (Printf.sprintf "INTERNAL ERROR: method %s not found" method_name);
	  assert false (* IMPOSSIBLE *)
      |	AstO.Class (_, base_cls, _, methods) ->
	  try
	    match List.find is_method methods with
		AstO.Method (_, typ, _, args, _) ->
		  Method (List.map (fun x -> Class (fst x)) args,Class typ)
	  with
	      Not_found -> type_of_method st (Class base_cls) method_name

let rec subtype st cls cls' =
  if cls = cls' then
    true
  else if cls = Class "Object" then
    false
  else
    match get_class st cls with
	AstO.Class (_, base_cls, _, _) -> subtype st (Class base_cls) cls'

let type_of st env0 expr0 =

  let aux_const _ = Class "Value" in

  let rec aux env =
    function
	AstO.Const k -> aux_const k
      | AstO.Id x -> List.assoc x env
      | AstO.FieldAccess (expr, field_name) ->
	  begin
	    match aux env expr with
		Class cls as x -> type_of_field st x field_name
	      | _ -> assert false (* TYPE ERROR *)
	  end
      | AstO.MethodCall (expr, method_name, exprs) ->
	  begin
	    match aux env expr with
		Class cls as x ->
		  begin
		    match type_of_method st x method_name with
			Method (typs, typ) ->
			  assert (List.length typs == List.length exprs);
			  assert (List.for_all2 (subtype st) (List.map (aux env) exprs) typs);
			  typ
		      | _ -> assert false (* TYPE ERROR *)
		  end
	      | _ -> assert false (* TYPE ERROR *)
	  end
      | AstO.StaticCall (cls, method_name, exprs) ->  
  	  begin
	    prerr_endline method_name;
  	    match (type_of_method st (Class cls) method_name) with    
  	  	Method (typs, typ) ->   
  	  	  assert (List.length typs == List.length exprs);   
  	  	  assert (List.for_all2 (subtype st) (List.map (aux env) exprs) typs);    
  	  	  typ   
                | _ -> assert false (* TYPE ERROR *)    
  	  end   
      | AstO.Let (decls, expr) -> aux (List.map (aux_let_decl env) decls @ env) expr 
      | AstO.New (decls, expr) ->
	  let env' = List.map (fun (x, cls, _) -> (x,Class cls)) decls @ env in
	    List.iter (aux_new_decl env') decls; 
	    aux env' expr
      | AstO.If (expr1, expr2, expr3) ->
	  begin
	    let cls2 = aux env expr2
	    and cls3 = aux env expr3 in
	      assert (cls2 = cls3);
	      cls2
	  end
      | AstO.Cast (cls',expr) -> 
	   begin 
 	    match aux env expr with 
 		Class cls as x -> 
		  prerr_endline (Printf.sprintf "checking %s <: %s" cls' cls);
 		  assert (subtype st (Class cls') x || subtype st x (Class cls')); 
 		  Class cls' 
 	      | _ -> assert false (*TYPE ERROR *) 
 	  end  


  and aux_let_decl env (x, expr) = (x, aux env expr)   
  and aux_new_decl env (_, cls, exprs) =  
    assert (List.for_all2 (subtype st) (List.map (aux env) exprs) (List.map snd (get_fields st (Class cls)))) 
  in 
    print_endline "IN";
    let res =
      match aux env0 expr0 with
	  Class cls -> cls
	| _ ->  assert false (* IMPOSSIBLE *) 
    in
      print_endline "OUT";
      res
	    
